Celestin Apprentice 5/Apprentice-Release5.iso/Source Code/C/Applications/Moscow ML 1.31/source code/mosml/src/compiler/Compiler.sml

Text File | 1996-07-03 | 11.4 KB | 422 lines | [TEXT/R*ch]

(* Compiler.sml *)

open List Obj BasicIO Nonstdio Fnlib Mixture Const Globals Location Units;
open Types Smlperv Asynt Parser Ovlres Infixres Elab Sigmtch;
open Tr_env Front Back Pr_zam Emit_phr;

(* Lexer of stream *)

fun createLexerStream (is : BasicIO.instream) =
  Lexing.createLexer (fn buff => fn n => Nonstdio.buff_input is buff 0 n)
;

(* Parsing functions *)

fun parsePhrase parsingFun lexingFun lexbuf =
  let fun skip() =
    (case lexingFun lexbuf of
        EOF => ()
      | SEMICOLON => ()
      | _ => skip())
    handle LexicalError(_,_,_) =>
      skip()
  in
    parsingFun lexingFun lexbuf
    handle
        Parsing.ParseError f =>
           let val pos1 = Lexing.getLexemeStart lexbuf
               val pos2 = Lexing.getLexemeEnd lexbuf
           in
             Lexer.resetLexerState();
             if f (Obj.repr EOF) orelse
                f (Obj.repr SEMICOLON)
             then () else skip();
             msgIBlock 0;
             errLocation (Loc(pos1, pos2));
             errPrompt "Syntax error.";
             msgEOL();
             msgEBlock();
             raise Toplevel
           end
       | LexicalError(msg, pos1, pos2) =>
           (msgIBlock 0;
            if pos1 >= 0 andalso pos2 >= 0 then
              errLocation (Loc(pos1, pos2))
            else ();
            errPrompt "Lexical error: "; msgString msg;
            msgString "."; msgEOL();
            msgEBlock();
            skip();
            raise Toplevel)
       | Toplevel =>
           (skip ();
            raise Toplevel)
  end
;

fun parsePhraseAndClear parsingFun lexingFun lexbuf =
  let val phr =
    parsePhrase parsingFun lexingFun lexbuf
    handle x => (Lexer.resetLexerState(); Parsing.clearParser(); raise x)
  in
    Lexer.resetLexerState();
    Parsing.clearParser();
    phr
  end;

val parseToplevelPhrase =
  parsePhraseAndClear Parser.ToplevelPhrase Lexer.Token
;

val parseBodyPhrase =
  parsePhraseAndClear Parser.BodyPhrase Lexer.Token
;

val parseToplevelSpecPhrase =
  parsePhraseAndClear Parser.SpecPhrase Lexer.Token
;

fun isInTable key tbl =
  (Hasht.find tbl key; true)
  handle Subscript => false
;

fun filter p xs =
  rev(foldL (fn x => fn acc => if p x then x::acc else acc) [] xs)
;

fun filterExcRenList excRenList cBas =
  filter (fn ({qual, id}, _) => isInTable id cBas) excRenList
;

fun filterValRenList valRenList cBas =
  filter (fn (id, stamp) => isInTable id cBas) valRenList
;

fun cleanEnvAcc [] acc = acc
  | cleanEnvAcc ((k, v) :: rest) acc =
      if exists (fn (k', _) => k = k') acc then
        cleanEnvAcc rest acc
      else
        cleanEnvAcc rest ((k, v) :: acc)
;

fun cleanEnv env =
  cleanEnvAcc (foldEnv (fn a => fn x => fn acc => (a,x)::acc) [] env) []
;

(* Reporting the results of compiling a phrase *)

val verbose = ref false;

fun reportFixityResult (id, status) =
(
  (case status of
       NONFIXst =>
         msgString "nonfix "
     | INFIXst i =>
         (msgString "infix ";
          msgInt i; msgString " ")
     | INFIXRst i =>
         (msgString "infixr ";
          msgInt i; msgString " "));
  msgString id
);

fun reportEquOfType equ =
  msgString
    (case equ of
         FALSEequ => ""
       | TRUEequ => "eq"
       | REFequ => "prim_EQ")
;

fun reportLhsOfTypeResult (tyname : TyName) =
  let val vs = newTypeVars (#tnArity (!(#info tyname)))
      val lhs = type_con (map TypeOfTypeVar vs) tyname
  in printType lhs end
;

fun reportTypeResult (tyname : TyName) =
  let val {qualid, info} = tyname
      val {tnEqu, tnStr, ...} = !info
  in
    case tnStr of
        NILts =>
          (reportEquOfType tnEqu;
           msgString "type ";
           reportLhsOfTypeResult tyname)
      | TYPEts(vs, tau) =>
          let val lhs = type_con (map TypeOfTypeVar vs) tyname in
            msgString "type ";
            resetTypePrinter();
            collectExplicitVars lhs;
            collectExplicitVars tau;
            printNextType lhs; msgString " ="; msgBreak(1, 2);
            printNextType tau;
            resetTypePrinter()
          end
      | DATATYPEts dt =>
          let val uname = #qual qualid
              val sig = if uname = currentUnitName()
                        then (!currentSig)
                        else findSig Location.nilLocation uname
              val CE = findConstructors sig dt
          in
            if null CE then
              (msgString "abstype ";
               reportLhsOfTypeResult tyname)
            else
              (msgString "datatype ";
               reportLhsOfTypeResult tyname)
          end
      | REAts _ =>
             fatalError "reportTypeResult"
  end
;

fun lookup_new_cBas cBas id =
  (lookupEnv cBas id : ConStatus)
  handle Subscript => fatalError "lookup_new_cBas"
;

fun report_comp_results iBas cBas static_VE static_TE =
(
  app (fn x =>
         (msgIBlock 0; reportFixityResult x; msgEOL(); msgEBlock()))
      (cleanEnv iBas);
  app (fn (id, tn) =>
         (msgIBlock 0; reportTypeResult tn; msgEOL(); msgEBlock()))
      (cleanEnv static_TE);
  app
    (fn (id, sch) =>
       let val status = lookup_new_cBas cBas id in
         msgIBlock 0;
         msgCBlock 0;
         msgString
           (case #info status of
               VARname  _ => "val "
             | PRIMname _ => "val "
             | CONname  _ => "con "
             | EXNname  _ => "exn "
             | REFname    => "con ");
         msgString id;
         msgString " :"; msgBreak(1, 2); printScheme sch;
         msgEBlock();
         msgEOL();
         msgEBlock()
       end)
    (cleanEnv static_VE);
    msgFlush()
);

(* To write the signature of the unit currently compiled *)
(* The same value has to be written twice, because it's unclear *)
(* how to `open` a file in "read/write" mode in a Caml Light program. *)

fun writeCompiledSignature filename_ui =
  let val sigStamp = ref dummySigStamp
      val sigLen = ref 0
  in
    let val os = open_out_bin filename_ui in
      (output_value os (!currentSig);
       sigLen := pos_out os;
       close_out os)
      handle x =>
        (close_out os;
         remove_file filename_ui;
         raise x)
    end;
    let val is = open_in_bin filename_ui in
      let val sigImage = input(is, !sigLen) in
        if size sigImage < !sigLen then raise Size else ();
        close_in is;
        remove_file filename_ui;
        sigStamp := Crc.crcOfString sigImage
      end
      handle x =>
        (close_in is;
         remove_file filename_ui;
         raise x)
    end;
    let val os = open_out_bin filename_ui in
      (output(os, !sigStamp);
       output_value os (!currentSig);
       close_out os)
      handle x =>
        (close_out os;
         remove_file filename_ui;
         raise x)
    end;
    !sigStamp
  end;

(* Compiling a signature *)

fun compileSpecPhrase spec =
  let val (iBas, cBas) = resolveToplevelSpec spec
      val (VE, TE) = elabToplevelSpec spec
  in
    updateCurrentInfixBasis iBas;
    extendCurrentConBasis cBas;
    extendCurrentStaticTE TE;
    updateCurrentStaticVE VE;
    if !verbose then
      (report_comp_results iBas cBas VE TE;
       msgFlush())
    else ()
  end
;

fun compileSignature uname filename =
  let
    val source_name = filename ^ ".sig"
    val target_name = filename ^ ".ui"
    (* val () = (msgIBlock 0;
                 msgString "[compiling file \""; msgString source_name;
                 msgString "\"]"; msgEOL(); msgEBlock();) *)
    val () = startCompilingUnit uname
    val () = initInitialEnvironments()
    val is = open_in_bin source_name
    val () = remove_file target_name;
    val lexbuf = createLexerStream is
  in
    input_name := source_name;
    input_stream := is;
    input_lexbuf := lexbuf;
    (while true do
       let val (phrase, isLast) = parseToplevelSpecPhrase lexbuf in
         compileSpecPhrase phrase;
         if isLast then raise EndOfFile else ()
       end)
    handle
      EndOfFile =>
        let val (_, _) = rectifySignature()
            val sigStamp = writeCompiledSignature target_name
        in close_in is end
    | x =>
        (close_in is;
         raise x)
  end
;

(* Compiling an implementation *)

(* This is written in tail-recursive form to ensure *)
(* that the intermediate results will be discarded. *)

fun updateCurrentCompState ((iBas, cBas, VE, TE), RE) =
(
  updateCurrentInfixBasis iBas;
  updateCurrentConBasis cBas;
  updateCurrentStaticTE TE;
  updateCurrentStaticVE VE;
  updateCurrentRenEnv RE;
  if !verbose then
    (report_comp_results iBas cBas VE TE;
     msgFlush())
  else ()
);

fun compLamPhrase os state (RE, lams) =
(
  app
    (fn (is_pure, lam) =>
       ((* msgIBlock 0; printLam lam; msgEOL(); msgEBlock(); *)
       emit_phrase os
         let val zam = compileLambda is_pure lam in
           (* printZamPhrase zam; msgFlush(); *)
           zam
         end))
    lams;
    updateCurrentCompState (state, RE)
);

fun compResolvedDecPhrase os (iBas, cBas, dec) =
  let val (VE, TE) = elabToplevelDec dec in
    resolveOvlDec dec;
    compLamPhrase os (iBas, cBas, VE, TE) (translateToplevelDec dec)
  end
;

fun compileImplPhrase os dec =
  compResolvedDecPhrase os (resolveToplevelDec dec)
;

fun compileImpl uname filename specSig_opt =
  let
    val filename_sml = filename ^ ".sml"
    val filename_ui  = filename ^ ".ui"
    val filename_uo  = filename ^ ".uo"
    (* val () = (msgIBlock 0;
                 msgString "[compiling file \""; msgString filename_sml;
                 msgString "\"]"; msgEOL(); msgEBlock()) *)
    val () = startCompilingUnit uname
    val () = initInitialEnvironments()
    val is = open_in_bin filename_sml
    val os = open_out_bin filename_uo
    val lexbuf = createLexerStream is
  in
    input_name := filename_sml;
    input_stream := is;
    input_lexbuf := lexbuf;
    (
      start_emit_phrase os;
      (while true do
         let val (phrase, isLast) = parseBodyPhrase lexbuf in
           compileImplPhrase os phrase;
           if isLast then raise EndOfFile else ()
         end)
      handle EndOfFile =>
        let val (excRenList, valRenList) = rectifySignature() in
          (case specSig_opt of
               NONE =>
                 let val sigStamp = writeCompiledSignature filename_ui in
                   end_emit_phrase
                     excRenList valRenList
                     sigStamp (#uMentions (!currentSig))
                     os
                 end
             | SOME specSig =>
                 let val {uConBasis, uStamp, ...} = specSig in
                   matchSignature os (!currentSig) specSig;
                   end_emit_phrase
                     (filterExcRenList excRenList uConBasis)
                     (filterValRenList valRenList uConBasis)
                     (getOption (!uStamp)) (#uMentions (!currentSig))
                     os
                 end);
          close_in is;
          close_out os
        end
    )
    handle x =>
      (close_in is;
       close_out os;
       remove_file filename_uo;
       raise x)
  end
;

fun compileUnitBody uname filename =
  let val filename_sig = filename ^ ".sig"
      val filename_ui  = filename ^ ".ui"
  in
    if file_exists filename_sig then
      (hasSpecifiedSignature := true;
       if not(file_exists filename_ui) then
         (msgIBlock 0;
          errPrompt "File "; msgString filename_sig;
          msgString " must be compiled before ";
          msgString filename; msgString ".sml"; msgEOL();
          msgEBlock();
          raise Toplevel)
       else ();
       compileImpl uname filename (SOME (readSig uname)))
    else
      (hasSpecifiedSignature := false;
       remove_file filename_ui;
       compileImpl uname filename NONE)
  end
;